home *** CD-ROM | disk | FTP | other *** search
- ------------------------------------------------------------------------------
- -- --
- -- GNAT COMPILER COMPONENTS --
- -- --
- -- A D A . E X C E P T I O N S --
- -- --
- -- B o d y --
- -- --
- -- $Revision: 1.13 $ --
- -- --
- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
- -- --
- -- GNAT is free software; you can redistribute it and/or modify it under --
- -- terms of the GNU General Public License as published by the Free Soft- --
- -- ware Foundation; either version 2, or (at your option) any later ver- --
- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
- -- for more details. You should have received a copy of the GNU General --
- -- Public License distributed with GNAT; see file COPYING. If not, write --
- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
- -- MA 02111-1307, USA. --
- -- --
- -- As a special exception, if other files instantiate generics from this --
- -- unit, or you link this unit with other files to produce an executable, --
- -- this unit does not by itself cause the resulting executable to be --
- -- covered by the GNU General Public License. This exception does not --
- -- however invalidate any other reasons why the executable file might be --
- -- covered by the GNU Public License. --
- -- --
- -- GNAT was originally developed by the GNAT team at New York University. --
- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
- -- --
- ------------------------------------------------------------------------------
-
- with Ada.IO_Exceptions; use Ada.IO_Exceptions;
- with Ada.IO_Exceptions; use Ada.IO_Exceptions;
- with System.Task_Specific_Data; use System.Task_Specific_Data;
- with System.Exception_Table; use System.Exception_Table;
- with Unchecked_Conversion;
-
- package body Ada.Exceptions is
-
- procedure Internal_Raise (X : Exception_Id);
- pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
-
- type Buffer_Ptr is access SSL.Exception_Message_Buffer;
- -- A thin pointer to String
-
- function To_Buffer_Ptr is
- new Unchecked_Conversion (System.Address, Buffer_Ptr);
- -- Conversion from address to string access for exception msg manipulation
-
- --------------------
- -- Exception_Name --
- --------------------
-
- function Exception_Name (X : Exception_Id) return String is
- begin
- if X = Null_Id then
- raise Constraint_Error;
- end if;
-
- return X.Full_Name.all (1 .. X.Name_Length - 1);
- end Exception_Name;
-
- ---------------------
- -- Raise_Exception --
- ---------------------
-
- procedure Raise_Exception
- (E : in Exception_Id;
- Message : in String := "")
- is
- Len : constant Natural :=
- Natural'Min
- (Message'Length, SSL.Exception_Message_Buffer'Length);
-
- -- ??? implementation of variable-length messages:
- -- if the message is bigger than the actual Exception_Message_Buffer
- -- the actual buffer should be freed and a bigger buffer should be
- -- reallocated (it means that the size of the actual buffer should
- -- be recorder int the TSD)
-
- begin
- if E = Null_Id then
- null;
-
- else
- Set_Message_Length (Len);
- To_Buffer_Ptr (Get_Message_Addr).all (1 .. Len) :=
- Message (Message'First .. Message'First + Len - 1);
- Internal_Raise (E);
- end if;
- end Raise_Exception;
-
- -----------------------
- -- Exception_Message --
- -----------------------
-
- function Exception_Message (X : Exception_Occurrence) return String is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- return X.Msg (1 .. X.Msg_Length);
- end Exception_Message;
-
- ------------------------
- -- Reraise_Occurrence --
- ------------------------
-
- procedure Reraise_Occurrence (X : Exception_Occurrence) is
- begin
- if X.Id = Null_Id then
- return;
-
- else
- Raise_Exception (X.Id, X.Msg (1 .. X.Msg_Length));
- end if;
- end Reraise_Occurrence;
-
- ------------------------
- -- Exception_Identity --
- ------------------------
-
- function Exception_Identity
- (X : Exception_Occurrence)
- return Exception_Id
- is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- return X.Id;
- end Exception_Identity;
-
- --------------------
- -- Exception_Name --
- --------------------
-
- function Exception_Name (X : Exception_Occurrence) return String is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- return X.Id.Full_Name.all (1 .. X.Id.Name_Length - 1);
- end Exception_Name;
-
- ---------------------------
- -- Exception_Information --
- ---------------------------
-
- function Exception_Information (X : Exception_Occurrence) return String is
- begin
- if X.Id = Null_Id then
- raise Constraint_Error;
- end if;
-
- return "";
- end Exception_Information;
-
- ---------------------------------------
- -- Exception_Occurrence_Access_Input --
- ---------------------------------------
-
- function Exception_Occurrence_Access_Input
- (Stream : access Ada.Streams.Root_Stream_Type'Class)
- return Exception_Occurrence_Access
- is
- Max : Natural := Natural'Input (Stream);
- Name : String := String'Input (Stream);
- Len : Natural := Natural'Input (Stream);
- Msg : String := String'Input (Stream);
-
- Item : Exception_Occurrence_Access := new Exception_Occurrence (Max);
-
- begin
- Item.Id := Exception_Id (Internal_Exception (Name));
-
- if Msg'Length /= Len or else Len > Max then
- raise Data_Error;
- end if;
-
- Item.Msg_Length := Len;
- Item.Msg := Msg;
-
- return Item;
-
- end Exception_Occurrence_Access_Input;
-
- -------------------------------
- -- Exception_Occurrence_Read --
- -------------------------------
-
- procedure Exception_Occurrence_Read
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : out Exception_Occurrence)
- is
- Name : String := String'Input (Stream);
- Len : Natural := Natural'Input (Stream);
- Msg : String := String'Input (Stream);
-
- begin
- Item.Id := Exception_Id (Internal_Exception (Name));
-
- if Msg'Length /= Len then
- raise Data_Error;
- end if;
-
- -- Silently truncate message if it does not fit
-
- Item.Msg_Length := Natural'Min (Len, Item.Max_Length);
- Item.Msg (1 .. Item.Msg_Length) := Msg (1 .. Item.Msg_Length);
- end Exception_Occurrence_Read;
-
- --------------------------------
- -- Exception_Occurrence_Write --
- --------------------------------
-
- procedure Exception_Occurrence_Write
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : in Exception_Occurrence)
- is
- begin
- String'Output (Stream, Exception_Name (Item.Id));
- Natural'Output (Stream, Item.Msg_Length);
- String'Output (Stream, Item.Msg (1 .. Item.Msg_Length));
-
- end Exception_Occurrence_Write;
-
- ---------------------
- -- Save_Occurrence --
- ---------------------
-
- procedure Save_Occurrence
- (Target : out Exception_Occurrence;
- Source : in Exception_Occurrence)
- is
- begin
- Target.Id := Source.Id;
-
- -- Case of truncation required
-
- if Target.Max_Length < Source.Msg_Length then
- Target.Msg_Length := Target.Max_Length;
- Target.Msg := Source.Msg (1 .. Target.Max_Length);
-
- -- Case of no truncation required
-
- else
- Target.Msg_Length := Source.Msg_Length;
- Target.Msg (1 .. Target.Msg_Length) :=
- Source.Msg (1 .. Target.Msg_Length);
- end if;
- end Save_Occurrence;
-
- function Save_Occurrence
- (Source : in Exception_Occurrence)
- return Exception_Occurrence_Access
- is
- X : Exception_Occurrence_Access;
-
- begin
- X := new Exception_Occurrence (Source.Msg_Length);
-
- X.Id := Source.Id;
- X.Msg_Length := Source.Msg_Length;
- X.Msg := Source.Msg;
-
- return X;
- end Save_Occurrence;
-
- ------------------------------
- -- Set_Exception_Occurrence --
- ------------------------------
-
- procedure Set_Exception_Occurrence (Occ : Exception_Occurrence_Access) is
- use System.Task_Specific_Data;
-
- Len : constant Natural := Get_Message_Length;
-
- begin
- Occ.Msg_Length := Len;
- Occ.Msg (1 .. Len) := To_Buffer_Ptr (Get_Message_Addr).all (1 .. Len);
- end Set_Exception_Occurrence;
- end Ada.Exceptions;
-